home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / pp.t < prev    next >
Text File  |  1988-02-05  |  4KB  |  115 lines
  1. (herald pp (env tsys))
  2.  
  3. ;;;; a pretty-printer
  4.  
  5. (define-operation (pretty-print obj port)
  6.   (print obj port))
  7.  
  8. ;;; handler for lists.
  9.  
  10. (define (pp-list x port)
  11.   (cond ((read-macro-inverse x)
  12.          => (lambda (inverse)
  13.               (writes port inverse)
  14.               (pretty-print (cadr x) port)))
  15.         ((print-width-greater? x (fx- (line-length port) (hpos port)))
  16.          ;; if ordinary print won't win...
  17.          (pp-list-vertically x port))
  18.         (else
  19.          (pp-list-horizontally x port))))
  20.  
  21. ;++ obsolete
  22.  
  23. (define (print-width-greater? obj n)
  24.   (catch abort
  25.     (let ((count 0))
  26.       (print obj (object nil
  27.                    ((writec self char)
  28.                     (ignore char)
  29.                     (set count (fx+ count 1))
  30.                     (if (fx> count n) (abort t)))
  31.                    ((writes self string)
  32.                     (set count (fx+ count (string-length string)))
  33.                     (if (fx> count n) (abort t)))
  34.                    ((output-port? self) '#t)
  35.                    ((port? self) '#t)
  36.                    ((print-type-string self) "Output-port"))))
  37.     nil))
  38.  
  39.  
  40. (define (pp-list-vertically   x port)
  41.   (maybe-pp-list-vertically t x port))
  42.  
  43. (define (pp-list-horizontally x port)
  44.   (maybe-pp-list-vertically nil x port))
  45.  
  46. (define (maybe-pp-list-vertically vertical? list port)
  47.   (writec port #\()
  48.   (if (null? list) (writec port #\))
  49.     (let ((old-hpos (hpos port)))
  50.       (pretty-print (if (syntax-descriptor? (car list))
  51.                         (identification (car list))
  52.                         (car list))
  53.                     port)
  54.       (if (and vertical? ;heuristic for things like do, cond, ...
  55.                (pair? (car list))
  56.                (not (null? (cdr list))))
  57.           (indent-newline (fx- old-hpos 1) port))
  58.       (let ((old-hpos (fx+ (hpos port) 1)))
  59.         (iterate tail ((flag nil) (l (cdr list)))
  60.           (cond ((pair? l)
  61.                  (cond (flag (indent-newline old-hpos port))
  62.                        (else (writec port #\space))) ; not (space port)!
  63.                  (pretty-print (car l) port)
  64.                  (tail vertical? (cdr l)))
  65.                 (else
  66.                  (cond ((not (null? l))
  67.                         (format port " . ")
  68.                         (if flag (indent-newline old-hpos port))
  69.                         (pretty-print l port)))
  70.                  (writec port #\)))))))))
  71.  
  72. ;;; utility: go to given column on a new line.
  73.  
  74. (define (indent-newline x port)
  75.   (newline port)
  76.   (set-hpos port x))
  77.  
  78. ;;; find printed representation for internal representation of read
  79. ;;; macro.
  80.  
  81. (define (read-macro-inverse x)
  82.   (cond ((and (pair? x)
  83.               (pair? (cdr x))
  84.               (null? (cddr x)))
  85.          (case (car x)
  86.            ((quote)            "'")
  87.            ((quasiquote)       "`")
  88.            ((unquote)          ",")
  89.            ((unquote-splicing) ",@")
  90.            (else nil)))
  91.         (else nil)))
  92.  
  93. ;;; "user interface" stuff
  94.  
  95. (define (*pp-symbol symbol env)
  96.   (*pp (cond ((syntax-table-entry (env-syntax-table env) symbol)
  97.               => identity)
  98.              ((env-lookup env symbol nil nil)
  99.               => (lambda (loc)
  100.                    (let ((val (contents loc)))
  101.                      (cond ((nonvalue? val) 'unbound)
  102.                            (else val)))))
  103.              (else 'unbound))))
  104.  
  105. (define (*pp obj)
  106.   (let ((obj (or (disclose obj) obj)))
  107.     (let ((port (terminal-output)))
  108.       (fresh-line port)
  109.       (cond ((and (procedure? obj) (where-defined obj))
  110.              => (lambda (where) (format port "~&;see ~a~%" where)))
  111.             (else
  112.              (pretty-print obj port)))
  113.       (fresh-line port)
  114.       repl-wont-print)))
  115.